perm filename INVER2.LSP[W78,JMC] blob sn#341531 filedate 1978-03-19 generic text, type T, neo UTF8

(DEFUN INVERT (PAT EXP ALISTS) 
       (COND ((OR (NULL PAT) (EQ PAT T) (NUMBERP PAT))
	      (COND ((EQUAL PAT EXP) ALISTS) (T NIL)))
	     ((ATOM PAT)
	      (MAPAPPEND (FUNCTION (LAMBDA (ALIST) ((LAMBDA (Z) 
						     (COND ((NULL Z)
							    (LIST
							     (CONS
							      (CONS
							       PAT
							       EXP)
							      ALIST)))
							   ((EQUAL
							     (CDR Z)
							     EXP)
							    (LIST
							     ALIST))
							   (T NIL)))
						    (ASSOC PAT
							   ALIST))))
			 ALISTS))
	     ((EQ (CAR PAT) 'QUOTE)
	      (COND ((EQUAL (CADR PAT) EXP) ALISTS) (T NIL)))
	     ((EQ (CAR PAT) 'CONS)
	      (COND ((ATOM EXP) NIL)
		    (T (INVERT (CADDR PAT)
			       (CDR EXP)
			       (INVERT (CADR PAT)
				       (CAR EXP)
				       ALISTS)))))
	     ((EQ (CAR PAT) 'LIST)
	      (INVERT (COND ((NULL (CDR PAT)) 'NIL)
			    (T (LIST 'CONS
				     (CADR PAT)
				     (CONS 'LIST (CDDR PAT)))))
		      EXP
		      ALISTS))
	     ((EQ (CAR PAT) 'APPEND)
	      (MAPAPPEND (FUNCTION (LAMBDA (Z) 
					   (INVERT (CONS 'LIST
							 (CDR PAT))
						   Z
						   ALISTS)))
			 (SEGMENTS EXP (LENGTH (CDR PAT))))))) 

(DEFUN MAPAPPEND (F U) 
       (COND ((NULL U) NIL)
	     (T (APPEND (F (CAR U)) (MAPAPPEND F (CDR U)))))) 

(DEFUN SPLIT (U) 
       (CONS (LIST NIL U)
	     (COND ((NULL U) NIL)
		   (T (MAPCAR (FUNCTION (LAMBDA (Z) 
						(CONS (CONS (CAR U)
							    (CAR Z))
						      (CDR Z))))
			      (SPLIT (CDR U))))))) 

(DEFUN SEGMENTS (U N) 
       (COND
	((EQUAL N 1.) (LIST (LIST U)))
	(T
	 (MAPAPPEND
	  (FUNCTION
	   (LAMBDA (W) (MAPCAR (FUNCTION (LAMBDA (Z) 
						 (APPEND Z (CDR W))))
			       (SPLIT (CAR W)))))
	  (SEGMENTS U (SUB1 N))))))